home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / libs / svgabg55 / vgademo.pas < prev    next >
Pascal/Delphi Source File  |  1994-06-25  |  56KB  |  2,003 lines
  1. program BGIDemo;
  2. {
  3.  
  4.   Turbo Pascal Borland Graphics Interface (BGI) demonstration
  5.   program. This program shows how to use many features of
  6.   the Graph unit.
  7.  
  8.   Copyright (c) 1985-89 by Borland International, Inc.
  9.  
  10. }
  11.  
  12. uses
  13.   Crt, Dos, Graph;
  14.  
  15.  
  16. const
  17.   { The five fonts available }
  18.   Fonts : array[0..4] of string[13] =
  19.   ('DefaultFont', 'TriplexFont', 'SmallFont', 'SansSerifFont', 'GothicFont');
  20.  
  21.   { The five predefined line styles supported }
  22.   LineStyles : array[0..4] of string[9] =
  23.   ('SolidLn', 'DottedLn', 'CenterLn', 'DashedLn', 'UserBitLn');
  24.  
  25.   { The twelve predefined fill styles supported }
  26.   FillStyles : array[0..11] of string[14] =
  27.   ('EmptyFill', 'SolidFill', 'LineFill', 'LtSlashFill', 'SlashFill',
  28.    'BkSlashFill', 'LtBkSlashFill', 'HatchFill', 'XHatchFill',
  29.    'InterleaveFill', 'WideDotFill', 'CloseDotFill');
  30.  
  31.   { The two text directions available }
  32.   TextDirect : array[0..1] of string[8] = ('HorizDir', 'VertDir');
  33.  
  34.   { The Horizontal text justifications available }
  35.   HorizJust  : array[0..2] of string[10] = ('LeftText', 'CenterText', 'RightText');
  36.  
  37.   { The vertical text justifications available }
  38.   VertJust   : array[0..2] of string[10] = ('BottomText', 'CenterText', 'TopText');
  39.  
  40. var
  41.   GraphDriver : integer;  { The Graphics device driver }
  42.   GraphMode   : integer;  { The Graphics mode value }
  43.   MaxX, MaxY  : word;     { The maximum resolution of the screen }
  44.   ErrorCode   : integer;  { Reports any graphics errors }
  45.   MaxColor    : Longint;     { The maximum color value available }
  46.   OldExitProc : Pointer;  { Saves exit procedure address }
  47.  
  48. function RealPixelColor(PixColor : LongInt) : LongInt;
  49. var
  50.   CurC : Integer;
  51. begin
  52.   RealPixelColor := PixColor;
  53. end;
  54.  
  55. function RealDrawColor(Color : LongInt) : LongInt;
  56. var
  57.   MaxC : Longint;
  58. begin
  59.   MaxC := GetMaxColor;
  60.  
  61.   if (MaxC = 65535) then
  62.     SetRgbPalette(1024,(Color SHR 11) AND 31,(Color SHR 5)AND 63,Color AND 31)
  63.   else if (MaxC = 32767) then
  64.     SetRgbPalette(1024,(Color SHR 10) AND 31,(Color SHR 5)AND 31,Color AND 31)
  65.   else if (MaxC = 16777) then
  66.   begin
  67.     SetRgbPalette(1024,(Color SHR 16) AND 255,(Color SHR 8)AND 255,Color AND 255);
  68.   end;
  69.   RealDrawColor := Color;
  70. end;
  71.  
  72. function RealFillColor(Color : LongInt) : LongInt;
  73. var
  74.   MaxC : Longint;
  75. begin
  76.   MaxC := GetMaxColor;
  77.  
  78.   if (MaxC = 65535) then
  79.     SetRgbPalette(1025,(Color SHR 11) AND 31,(Color SHR 5)AND 63,Color AND 31)
  80.   else if (MaxC = 32767) then
  81.     SetRgbPalette(1025,(Color SHR 10) AND 31,(Color SHR 5)AND 31,Color AND 31)
  82.   else if (MaxC = 16777) then
  83.   begin
  84.     SetRgbPalette(1025,(Color SHR 16) AND 255,(Color SHR 8)AND 255,Color AND 255);
  85.     Color := 0;
  86.   end;
  87.   RealFillColor := Color;
  88. end;
  89.  
  90. function RealColor(Color : LongInt) : LongInt;
  91. var
  92.   MaxC : Longint;
  93. begin
  94.   MaxC := GetMaxColor;
  95.  
  96.   if (MaxC = 65535) then
  97.     SetRgbPalette(1026,(Color SHR 11) AND 31,(Color SHR 5)AND 63,Color AND 31)
  98.   else if (MaxC = 32767) then
  99.     SetRgbPalette(1026,(Color SHR 10) AND 31,(Color SHR 5)AND 31,Color AND 31)
  100.   else if (MaxC = 16777) then
  101.   begin
  102.     SetRgbPalette(1026,(Color SHR 16) AND 255,(Color SHR 8)AND 255,Color AND 255);
  103.     Color := 0;
  104.   end;
  105.   RealColor := Color;
  106. end;
  107.  
  108. function WhitePixel : LongInt;
  109. var
  110.   Clr : LongInt;
  111. begin
  112.   Clr := GetMaxColor;
  113.  
  114.   if (Clr = 65535) then      Clr := $FFFF
  115.   else if (Clr = 32767) then Clr := $7FFF
  116.   else if (Clr = 16777) then Clr := $ffffff
  117.   else Clr := 15;
  118.   WhitePixel := Clr;
  119. end;
  120.  
  121. function BluePixel : LongInt;
  122. var
  123.   Clr : LongInt;
  124. begin
  125.   Clr := GetMaxColor;
  126.  
  127.   if (Clr = 65535) then      Clr := $1F
  128.   else if (Clr = 32767) then Clr := $1F
  129.   else if (Clr = 16777) then Clr := $ff
  130.   else Clr := 1;
  131.   BluePixel := Clr;
  132. end;
  133.  
  134. function GreenPixel : LongInt;
  135. var
  136.   Clr : LongInt;
  137. begin
  138.   Clr := GetMaxColor;
  139.  
  140.   if (Clr = 65535) then      Clr := 63 SHL 5
  141.   else if (Clr = 32767) then Clr := 31 SHL 5
  142.   else if (Clr = 16777) then Clr := $ff00
  143.   else Clr := 2;
  144.   GreenPixel := Clr;
  145. end;
  146.  
  147.  
  148. {$F+}
  149. procedure MyExitProc;
  150. begin
  151.   ExitProc := OldExitProc; { Restore exit procedure address }
  152.   CloseGraph;              { Shut down the graphics system }
  153. end; { MyExitProc }
  154. {$F-}
  155.  
  156. {$F+}
  157. function DetectVGA256 : integer;
  158. { Detects VGA or MCGA video cards }
  159. var
  160.   DetectedDriver : integer;
  161.   SuggestedMode  : integer;
  162. begin
  163.   DetectGraph(DetectedDriver, SuggestedMode);
  164.   if (DetectedDriver = VGA) or (DetectedDriver = MCGA) then
  165.   begin
  166.     Writeln('Which video mode would you like to use?');
  167.     Writeln('  0) 320x200x256');
  168.     Writeln('  1) 640x400x256');
  169.     Writeln('  2) 640x480x256');
  170.     Writeln('  3) 800x600x256');
  171.     Writeln('  4) 1024x768x256');
  172.     Writeln('  5) 640x350x256');
  173.     Writeln('  6) 1280x1024x256');
  174.     Write('> ');
  175.     Readln(SuggestedMode);
  176.     DetectVGA256 := SuggestedMode;
  177.   end
  178.   else
  179.     DetectVGA256 := grError; { Couldn't detect hardware }
  180. end; { DetectVGA256 }
  181. {$F-}
  182.  
  183. {$F+}
  184. function DetectVGA32k : integer;
  185. { Detects VGA or MCGA video cards }
  186. var
  187.   DetectedDriver : integer;
  188.   SuggestedMode  : integer;
  189. begin
  190.   DetectGraph(DetectedDriver, SuggestedMode);
  191.   if (DetectedDriver = VGA) or (DetectedDriver = MCGA) then
  192.   begin
  193.     Writeln('Which video mode would you like to use?');
  194.     Writeln('  0) 320x200x32k');
  195.     Writeln('  1) 640x350x32k');
  196.     Writeln('  2) 640x400x32k');
  197.     Writeln('  3) 640x480x32k');
  198.     Writeln('  4) 800x600x32k');
  199.     Writeln('  5) 1024x768x32k');
  200.     Writeln('  6) 1280x1024x32k');
  201.     Write('> ');
  202.     Readln(SuggestedMode);
  203.     DetectVGA32k := SuggestedMode;
  204.   end
  205.   else
  206.     DetectVGA32k := grError; { Couldn't detect hardware }
  207. end; { DetectVGA32k }
  208. {$F-}
  209.  
  210. {$F+}
  211. function DetectVGA64k : integer;
  212. { Detects VGA or MCGA video cards }
  213. var
  214.   DetectedDriver : integer;
  215.   SuggestedMode  : integer;
  216. begin
  217.   DetectGraph(DetectedDriver, SuggestedMode);
  218.   if (DetectedDriver = VGA) or (DetectedDriver = MCGA) then
  219.   begin
  220.     Writeln('Which video mode would you like to use?');
  221.     Writeln('  0) 320x200x64k');
  222.     Writeln('  1) 640x350x64k');
  223.     Writeln('  2) 640x400x64k');
  224.     Writeln('  3) 640x480x64k');
  225.     Writeln('  4) 800x600x64k');
  226.     Writeln('  5) 1024x768x64k');
  227.     Writeln('  6) 1280x1024x64k');
  228.     Write('> ');
  229.     Readln(SuggestedMode);
  230.     DetectVGA64k := SuggestedMode;
  231.   end
  232.   else
  233.     DetectVGA64k := grError; { Couldn't detect hardware }
  234. end; { DetectVGA32k }
  235. {$F-}
  236.  
  237. {$F+}
  238. function DetectVGA24bit : integer;
  239. { Detects VGA or MCGA video cards }
  240. var
  241.   DetectedDriver : integer;
  242.   SuggestedMode  : integer;
  243. begin
  244.   DetectGraph(DetectedDriver, SuggestedMode);
  245.   if (DetectedDriver = VGA) or (DetectedDriver = MCGA) then
  246.   begin
  247.     Writeln('Which video mode would you like to use?');
  248.     Writeln('  0) 320x200x24bit');
  249.     Writeln('  1) 640x350x24bit');
  250.     Writeln('  2) 640x400x24bit');
  251.     Writeln('  3) 640x480x24bit');
  252.     Writeln('  4) 800x600x24bit');
  253.     Writeln('  5) 1024x768x24bit');
  254.     Writeln('  6) 1280x1024x24bit');
  255.     Write('> ');
  256.     Readln(SuggestedMode);
  257.     DetectVGA24bit := SuggestedMode;
  258.   end
  259.   else
  260.     DetectVGA24bit := grError; { Couldn't detect hardware }
  261. end; { DetectVGA32k }
  262. {$F-}
  263.  
  264.  
  265. {$F+}
  266. function DetectTwk256 : integer;
  267. { Detects VGA or MCGA video cards }
  268. var
  269.   DetectedDriver : integer;
  270.   SuggestedMode  : integer;
  271. begin
  272.   DetectGraph(DetectedDriver, SuggestedMode);
  273.   if (DetectedDriver = VGA) or (DetectedDriver = MCGA) then
  274.   begin
  275.     Writeln('Which video mode would you like to use?');
  276.     Writeln('  0) 320x400x256');
  277.     Writeln('  1) 320x480x256');
  278.     Writeln('  2) 360x480x256');
  279.     Writeln('  3) 376x564x256');
  280.     Writeln('  4) 400x564x256');
  281.     Writeln('  5) 400x600x256');
  282.     Writeln('  6) 320x240x256');
  283.     Write('> ');
  284.     Readln(SuggestedMode);
  285.     DetectTwk256 := SuggestedMode;
  286.   end
  287.   else
  288.     DetectTwk256 := grError; { Couldn't detect hardware }
  289. end; { DetectVGA256 }
  290. {$F-}
  291.  
  292. {$F+}
  293. function DetectVGA16 : integer;
  294. { Detects VGA or MCGA video cards }
  295. var
  296.   DetectedDriver : integer;
  297.   SuggestedMode  : integer;
  298. begin
  299.   DetectGraph(DetectedDriver, SuggestedMode);
  300.   if (DetectedDriver = EGA) or (DetectedDriver = VGA) then
  301.   begin
  302.     Writeln('Which video mode would you like to use?');
  303.     Writeln('  0) 320x200x16');
  304.     Writeln('  1) 640x200x16');
  305.     Writeln('  2) 640x350x16');
  306.     Writeln('  3) 640x480x16');
  307.     Writeln('  4) 800x600x16');
  308.     Writeln('  5) 1024x768x16');
  309.     Writeln('  6) 1280x1024x16');
  310.     Write('> ');
  311.     Readln(SuggestedMode);
  312.     DetectVGA16 := SuggestedMode;
  313.   end
  314.   else
  315.     DetectVGA16 := grError; { Couldn't detect hardware }
  316. end; { DetectVGA256 }
  317. {$F-}
  318.  
  319. {$F+}
  320. function DetectTwk16 : integer;
  321. { Detects VGA or MCGA video cards }
  322. var
  323.   DetectedDriver : integer;
  324.   SuggestedMode  : integer;
  325. begin
  326.   DetectGraph(DetectedDriver, SuggestedMode);
  327.   if (DetectedDriver = VGA) then
  328.   begin
  329.     Writeln('Which video mode would you like to use?');
  330.     Writeln('  0) 704x528x16');
  331.     Writeln('  1) 720x540x16');
  332.     Writeln('  2) 736x552x16');
  333.     Writeln('  3) 752x564x16');
  334.     Writeln('  4) 768x576x16');
  335.     Writeln('  5) 784x588x16');
  336.     Writeln('  6) 800x600x16');
  337.     Write('> ');
  338.     Readln(SuggestedMode);
  339.     DetectTwk16 := SuggestedMode;
  340.   end
  341.   else
  342.     DetectTwk16 := grError; { Couldn't detect hardware }
  343. end; { DetectVGA256 }
  344. {$F-}
  345.  
  346. {$F+}
  347. function DetectText : integer;
  348. begin
  349.   DetectText := 0;
  350. end;
  351. {$F-}
  352.  
  353. {$F+}
  354. function DetectS3 : integer;
  355. { Detects VGA or MCGA video cards }
  356. var
  357.   DetectedDriver : integer;
  358.   SuggestedMode  : integer;
  359. begin
  360.   DetectGraph(DetectedDriver, SuggestedMode);
  361.   if (DetectedDriver = VGA) then
  362.   begin
  363.     Writeln('Which video mode would you like to use?');
  364.     Writeln('  0) 640x480x256');
  365.     Writeln('  1) 800x600x256');
  366.     Writeln('  2) 1024x768x256');
  367.     Writeln('  3) 800x600x16');
  368.     Writeln('  4) 1024x768x16');
  369.     Writeln('  5) 1280x960x16');
  370.     Writeln('  6) 1280x1024x16');
  371.     Writeln('  7) 640x480x32k');
  372.     Write('> ');
  373.     Readln(SuggestedMode);
  374.     DetectS3 := SuggestedMode;
  375.   end
  376.   else
  377.     DetectS3 := grError; { Couldn't detect hardware }
  378. end; { DetectVGA256 }
  379. {$F-}
  380.  
  381. var
  382.   AutoDetectPointer : pointer;
  383.  
  384. procedure Initialize;
  385. { Initialize graphics and report any errors that may occur }
  386. var
  387.   InGraphicsMode : boolean; { Flags initialization of graphics mode }
  388.   PathToDriver   : string;  { Stores the DOS path to *.BGI & *.CHR }
  389.   UseWhichDriver : integer;
  390. begin
  391.   { when using Crt and graphics, turn off Crt's memory-mapped writes }
  392.   DirectVideo := False;
  393.   OldExitProc := ExitProc;                { save previous exit proc }
  394.   ExitProc := @MyExitProc;                { insert our exit proc in chain }
  395.   PathToDriver := '';
  396.   repeat
  397.     Writeln('Which driver to use?');
  398.     Writeln('  0) Svga16');
  399.     Writeln('  1) Svga256');
  400.     Writeln('  2) Svga32k');
  401.     Writeln('  3) Svga64k');
  402.     Writeln('  4) SvgaS3');
  403.     Writeln('  5) SvgaTC');
  404.     Writeln('  6) Tweak16');
  405.     Writeln('  7) Tweak256');
  406.     Writeln('  8) Tweak Text');
  407.     Write('>');
  408.     Readln(UseWhichDriver);
  409.     if (UseWhichDriver = 0) then
  410.     begin
  411.       AutoDetectPointer := @DetectVGA16;
  412.       GraphDriver := InstallUserDriver('Svga16',AutoDetectPointer);
  413.     end
  414.     else if (UseWhichDriver=1) then
  415.     begin
  416.       AutoDetectPointer := @DetectVGA256;   { Point to detection routine }
  417.       GraphDriver := InstallUserDriver('SVGA256', AutoDetectPointer);
  418.     end
  419.     else if (UseWhichDriver=2) then
  420.     begin
  421.       AutoDetectPointer := @DetectVGA32k;
  422.       GraphDriver := InstallUserDriver('Svga32k',AutoDetectPointer);
  423.     end
  424.     else if (UseWhichDriver=3) then
  425.     begin
  426.       AutoDetectPointer := @DetectVGA64k;
  427.       GraphDriver := InstallUserDriver('Svga64k',AutoDetectPointer);
  428.     end
  429.     else if (UseWhichDriver=4) then
  430.     begin
  431.       AutoDetectPointer := @DetectS3;
  432.       GraphDriver := InstallUserDriver('SvgaS3',AutoDetectPointer);
  433.     end
  434.     else if (UseWhichDriver=5) then
  435.     begin
  436.       AutoDetectPointer := @DetectVGA24bit;
  437.       GraphDriver := InstallUserDriver('SvgaTC',AutoDetectPointer);
  438.     end
  439.     else if (UseWhichDriver=6) then
  440.     begin
  441.       AutoDetectPointer := @DetectTwk16;
  442.       GraphDriver := InstallUserDriver('Twk16',AutoDetectPointer);
  443.     end
  444.     else if (UseWhichDriver=7) then
  445.     begin
  446.       AutoDetectPointer := @DetectTwk256;
  447.       GraphDriver := InstallUserDriver('Twk256',AutoDetectPointer);
  448.     end
  449.     else if (UseWhichDriver=8) then
  450.     begin
  451.       AutoDetectPointer := @DetectText;
  452.       GraphDriver := InstallUserDriver('Twktext',AutoDetectPointer);
  453.     end;
  454.     GraphDriver := Detect;
  455.     InitGraph(GraphDriver, GraphMode, PathToDriver);
  456.     ErrorCode := GraphResult;             { preserve error return }
  457.     if ErrorCode AND $80 = $80 then
  458.        ErrorCode := ErrorCode OR $ff00;
  459.     if ErrorCode <> grOK then             { error? }
  460.     begin
  461.       Writeln('Graphics error: ', GraphErrorMsg(ErrorCode));
  462.       if ErrorCode = grFileNotFound then  { Can't find driver file }
  463.       begin
  464.         Writeln('Enter full path to BGI driver or type <Ctrl-Break> to quit:');
  465.         Readln(PathToDriver);
  466.         Writeln;
  467.       end
  468.       else
  469.         Halt(1);                          { Some other error: terminate }
  470.     end;
  471.   until ErrorCode = grOK;
  472.   Randomize;                { init random number generator }
  473.   MaxColor := GetMaxColor;  { Get the maximum allowable drawing color }
  474.   MaxX := GetMaxX;          { Get screen resolution values }
  475.   MaxY := GetMaxY;
  476. end; { Initialize }
  477.  
  478. function Int2Str(L : LongInt) : string;
  479. { Converts an integer to a string for use with OutText, OutTextXY }
  480. var
  481.   S : string;
  482. begin
  483.   Str(L, S);
  484.   Int2Str := S;
  485. end; { Int2Str }
  486.  
  487. function RandColor : LongInt;
  488. var
  489.   redVal : longint;
  490. { Returns a Random non-zero color value that is within the legal
  491.   color range for the selected device driver and graphics mode.
  492.   MaxColor is set to GetMaxColor by Initialize }
  493. begin
  494.   if (GetMaxColor = 16777) then
  495.   begin
  496.       redVal := Random(255);
  497.       RandColor := Random(65535)+(redVal SHL 16);
  498.   end
  499.   else
  500.       RandColor := Random(MaxColor)+1;
  501. end; { RandColor }
  502.  
  503. procedure DefaultColors;
  504. { Select the maximum color in the Palette for the drawing color }
  505. begin
  506.   SetColor(RealDrawColor(WhitePixel));
  507. end; { DefaultColors }
  508.  
  509. procedure DrawBorder;
  510. { Draw a border around the current view port }
  511. var
  512.   ViewPort : ViewPortType;
  513. begin
  514.   DefaultColors;
  515.   SetLineStyle(SolidLn, 0, NormWidth);
  516.   GetViewSettings(ViewPort);
  517.   with ViewPort do
  518.     Rectangle(0, 0, x2-x1, y2-y1);
  519. end; { DrawBorder }
  520.  
  521. procedure FullPort;
  522. { Set the view port to the entire screen }
  523. begin
  524.   SetViewPort(0, 0, MaxX, MaxY, ClipOn);
  525. end; { FullPort }
  526.  
  527. procedure MainWindow(Header : string);
  528. { Make a default window and view port for demos }
  529. begin
  530.   DefaultColors;                           { Reset the colors }
  531.   ClearDevice;                             { Clear the screen }
  532.   SetTextStyle(DefaultFont, HorizDir, 1);  { Default text font }
  533.   SetTextJustify(CenterText, TopText);     { Left justify text }
  534.   FullPort;                                { Full screen view port }
  535.   OutTextXY(MaxX div 2, 2, Header);        { Draw the header }
  536.   { Draw main window }
  537.   SetViewPort(0, TextHeight('M')+4, MaxX, MaxY-(TextHeight('M')+4), ClipOn);
  538.   DrawBorder;                              { Put a border around it }
  539.   { Move the edges in 1 pixel on all sides so border isn't in the view port }
  540.   SetViewPort(1, TextHeight('M')+5, MaxX-1, MaxY-(TextHeight('M')+5), ClipOn);
  541. end; { MainWindow }
  542.  
  543. procedure StatusLine(Msg : string);
  544. { Display a status line at the bottom of the screen }
  545. begin
  546.   FullPort;
  547.   DefaultColors;
  548.   SetTextStyle(DefaultFont, HorizDir, 1);
  549.   SetTextJustify(CenterText, TopText);
  550.   SetLineStyle(SolidLn, 0, NormWidth);
  551.   SetFillStyle(EmptyFill, RealFillColor(0));
  552.   Bar(0, MaxY-(TextHeight('M')+4), MaxX, MaxY);      { Erase old status line }
  553.   Rectangle(0, MaxY-(TextHeight('M')+4), MaxX, MaxY);
  554.   OutTextXY(MaxX div 2, MaxY-(TextHeight('M')+2), Msg);
  555.   { Go back to the main window }
  556.   SetViewPort(1, TextHeight('M')+5, MaxX-1, MaxY-(TextHeight('M')+5), ClipOn);
  557. end; { StatusLine }
  558.  
  559. procedure WaitToGo;
  560. { Wait for the user to abort the program or continue }
  561. const
  562.   Esc = #27;
  563. var
  564.   Ch : char;
  565. begin
  566.   StatusLine('Esc aborts or press a key...');
  567.   repeat until KeyPressed;
  568.   Ch := ReadKey;
  569.   if Ch = Esc then
  570.     Halt(0)                           { terminate program }
  571.   else
  572.     ClearDevice;                      { clear screen, go on with demo }
  573. end; { WaitToGo }
  574.  
  575. procedure GetDriverAndMode(var DriveStr, ModeStr : string);
  576. { Return strings describing the current device driver and graphics mode
  577.   for display of status report }
  578. begin
  579.   DriveStr := GetDriverName;
  580.   ModeStr := GetModeName(GetGraphMode);
  581. end; { GetDriverAndMode }
  582.  
  583. procedure ReportStatus;
  584. { Display the status of all query functions after InitGraph }
  585. const
  586.   X = 10;
  587. var
  588.   ViewInfo   : ViewPortType;     { Parameters for inquiry procedures }
  589.   LineInfo   : LineSettingsType;
  590.   FillInfo   : FillSettingsType;
  591.   TextInfo   : TextSettingsType;
  592.   Palette    : PaletteType;
  593.   DriverStr  : string;           { Driver and mode strings }
  594.   ModeStr    : string;
  595.   Y          : word;
  596.  
  597. procedure WriteOut(S : string);
  598. { Write out a string and increment to next line }
  599. begin
  600.   OutTextXY(X, Y, S);
  601.   Inc(Y, TextHeight('M')+2);
  602. end; { WriteOut }
  603.  
  604. begin { ReportStatus }
  605.   GetDriverAndMode(DriverStr, ModeStr);   { Get current settings }
  606.   GetViewSettings(ViewInfo);
  607.   GetLineSettings(LineInfo);
  608.   GetFillSettings(FillInfo);
  609.   GetTextSettings(TextInfo);
  610.   GetPalette(Palette);
  611.  
  612.   Y := 4;
  613.   MainWindow('Status report after InitGraph');
  614.   SetTextJustify(LeftText, TopText);
  615.   WriteOut('Graphics device    : '+DriverStr);
  616.   WriteOut('Graphics mode      : '+ModeStr);
  617.   WriteOut('Screen resolution  : (0, 0, '+Int2Str(GetMaxX)+', '+Int2Str(GetMaxY)+')');
  618.   with ViewInfo do
  619.   begin
  620.     WriteOut('Current view port  : ('+Int2Str(x1)+', '+Int2Str(y1)+', '+Int2Str(x2)+', '+Int2Str(y2)+')');
  621.     if ClipOn then
  622.       WriteOut('Clipping           : ON')
  623.     else
  624.       WriteOut('Clipping           : OFF');
  625.   end;
  626.   WriteOut('Current position   : ('+Int2Str(GetX)+', '+Int2Str(GetY)+')');
  627.   WriteOut('Palette entries    : '+Int2Str(Palette.Size));
  628.   WriteOut('GetMaxColor        : '+Int2Str(GetMaxColor));
  629.   WriteOut('Current color      : '+Int2Str(GetColor));
  630.   with LineInfo do
  631.   begin
  632.     WriteOut('Line style         : '+LineStyles[LineStyle]);
  633.     WriteOut('Line thickness     : '+Int2Str(Thickness));
  634.   end;
  635.   with FillInfo do
  636.   begin
  637.     WriteOut('Current fill style : '+FillStyles[Pattern]);
  638.     WriteOut('Current fill color : '+Int2Str(Color));
  639.   end;
  640.   with TextInfo do
  641.   begin
  642.     WriteOut('Current font       : '+Fonts[Font]);
  643.     WriteOut('Text direction     : '+TextDirect[Direction]);
  644.     WriteOut('Character size     : '+Int2Str(CharSize));
  645.     WriteOut('Horizontal justify : '+HorizJust[Horiz]);
  646.     WriteOut('Vertical justify   : '+VertJust[Vert]);
  647.   end;
  648.   WaitToGo;
  649. end; { ReportStatus }
  650.  
  651. procedure FillEllipsePlay;
  652. { Random filled ellipse demonstration }
  653. const
  654.   MaxFillStyles = 12; { patterns 0..11 }
  655. var
  656.   MaxRadius : word;
  657.   FillColor : LongInt;
  658. begin
  659.   MainWindow('FillEllipse demonstration');
  660.   StatusLine('Esc aborts or press a key');
  661.   MaxRadius := MaxY div 10;
  662.   SetLineStyle(SolidLn, 0, NormWidth);
  663.   repeat
  664.     FillColor := RandColor;
  665.     SetColor(RealDrawColor(FillColor));
  666.     SetFillStyle(Random(MaxFillStyles), RealFillColor(FillColor));
  667.     FillEllipse(Random(MaxX), Random(MaxY),
  668.                 Random(MaxRadius), Random(MaxRadius));
  669.   until KeyPressed;
  670.   WaitToGo;
  671. end; { FillEllipsePlay }
  672.  
  673. procedure SectorPlay;
  674. { Draw random sectors on the screen }
  675. const
  676.   MaxFillStyles = 12; { patterns 0..11 }
  677. var
  678.   MaxRadius : word;
  679.   FillColor : LongInt;
  680.   EndAngle  : integer;
  681. begin
  682.   MainWindow('Sector demonstration');
  683.   StatusLine('Esc aborts or press a key');
  684.   MaxRadius := MaxY div 10;
  685.   SetLineStyle(SolidLn, 0, NormWidth);
  686.   repeat
  687.     FillColor := RandColor;
  688.     SetColor(RealDrawColor(FillColor));
  689.     SetFillStyle(Random(MaxFillStyles), RealFillColor(FillColor));
  690.     EndAngle := Random(360);
  691.     Sector(Random(MaxX), Random(MaxY), Random(EndAngle), EndAngle,
  692.            Random(MaxRadius), Random(MaxRadius));
  693.   until KeyPressed;
  694.   WaitToGo;
  695. end; { SectorPlay }
  696.  
  697. procedure WriteModePlay;
  698. { Demonstrate the SetWriteMode procedure for XOR lines }
  699. const
  700.   DelayValue = 50;  { milliseconds to delay }
  701. var
  702.   ViewInfo      : ViewPortType;
  703.   Color         : LongInt;
  704.   Left, Top     : integer;
  705.   Right, Bottom : integer;
  706.   Step          : integer; { step for rectangle shrinking }
  707. begin
  708.   MainWindow('SetWriteMode demonstration');
  709.   StatusLine('Esc aborts or press a key');
  710.   GetViewSettings(ViewInfo);
  711.   Left := 0;
  712.   Top := 0;
  713.   with ViewInfo do
  714.   begin
  715.     Right := x2-x1;
  716.     Bottom := y2-y1;
  717.   end;
  718.   Step := Bottom div 50;
  719.   SetColor(RealDrawColor(WhitePixel));
  720.   Line(Left, Top, Right, Bottom);
  721.   Line(Left, Bottom, Right, Top);
  722.   SetWriteMode(XORPut);                    { Set XOR write mode }
  723.   repeat
  724.     Line(Left, Top, Right, Bottom);        { Draw XOR lines }
  725.     Line(Left, Bottom, Right, Top);
  726.     Rectangle(Left, Top, Right, Bottom);   { Draw XOR rectangle }
  727.     Delay(DelayValue);                     { Wait }
  728.     Line(Left, Top, Right, Bottom);        { Erase lines }
  729.     Line(Left, Bottom, Right, Top);
  730.     Rectangle(Left, Top, Right, Bottom);   { Erase rectangle }
  731.     if (Left+Step < Right) and (Top+Step < Bottom) then
  732.       begin
  733.         Inc(Left, Step);                  { Shrink rectangle }
  734.         Inc(Top, Step);
  735.         Dec(Right, Step);
  736.         Dec(Bottom, Step);
  737.       end
  738.     else
  739.       begin
  740.         Color := RandColor;                { New color }
  741.         SetColor(RealDrawColor(Color));
  742.         Left := 0;                         { Original large rectangle }
  743.         Top := 0;
  744.         with ViewInfo do
  745.         begin
  746.           Right := x2-x1;
  747.           Bottom := y2-y1;
  748.         end;
  749.       end;
  750.   until KeyPressed;
  751.   SetWriteMode(CopyPut);                   { back to overwrite mode }
  752.   WaitToGo;
  753. end; { WriteModePlay }
  754.  
  755. procedure AspectRatioPlay;
  756. { Demonstrate  SetAspectRatio command }
  757. var
  758.   ViewInfo   : ViewPortType;
  759.   CenterX    : integer;
  760.   CenterY    : integer;
  761.   Radius     : word;
  762.   Xasp, Yasp : word;
  763.   i          : integer;
  764.   RadiusStep : word;
  765. begin
  766.   MainWindow('SetAspectRatio demonstration');
  767.   GetViewSettings(ViewInfo);
  768.   with ViewInfo do
  769.   begin
  770.     CenterX := (x2-x1) div 2;
  771.     CenterY := (y2-y1) div 2;
  772.     Radius := 3*((y2-y1) div 5);
  773.   end;
  774.   RadiusStep := (Radius div 30);
  775.   Circle(CenterX, CenterY, Radius);
  776.   GetAspectRatio(Xasp, Yasp);
  777.   for i := 1 to 30 do
  778.   begin
  779.     SetAspectRatio(Xasp, Yasp+(I*GetMaxX));    { Increase Y aspect factor }
  780.     Circle(CenterX, CenterY, Radius);
  781.     Dec(Radius, RadiusStep);                   { Shrink radius }
  782.   end;
  783.   Inc(Radius, RadiusStep*30);
  784.   for i := 1 to 30 do
  785.   begin
  786.     SetAspectRatio(Xasp+(I*GetMaxX), Yasp);    { Increase X aspect factor }
  787.     if Radius > RadiusStep then
  788.       Dec(Radius, RadiusStep);                 { Shrink radius }
  789.     Circle(CenterX, CenterY, Radius);
  790.   end;
  791.   SetAspectRatio(Xasp, Yasp);                  { back to original aspect }
  792.   WaitToGo;
  793. end; { AspectRatioPlay }
  794.  
  795. procedure TextPlay;
  796. { Demonstrate text justifications and text sizing }
  797. var
  798.   Size : word;
  799.   W, H, X, Y : word;
  800.   ViewInfo : ViewPortType;
  801. begin
  802.   MainWindow('SetTextJustify / SetUserCharSize demo');
  803.   GetViewSettings(ViewInfo);
  804.   with ViewInfo do
  805.   begin
  806.     SetTextStyle(TriplexFont, VertDir, 4);
  807.     Y := (y2-y1) - 2;
  808.     SetTextJustify(CenterText, BottomText);
  809.     OutTextXY(2*TextWidth('M'), Y, 'Vertical');
  810.     SetTextStyle(TriplexFont, HorizDir, 4);
  811.     SetTextJustify(LeftText, TopText);
  812.     OutTextXY(2*TextWidth('M'), 2, 'Horizontal');
  813.     SetTextJustify(CenterText, CenterText);
  814.     X := (x2-x1) div 2;
  815.     Y := TextHeight('H');
  816.     for Size := 1 to 4 do
  817.     begin
  818.       SetTextStyle(TriplexFont, HorizDir, Size);
  819.       H := TextHeight('M');
  820.       W := TextWidth('M');
  821.       Inc(Y, H);
  822.       OutTextXY(X, Y, 'Size '+Int2Str(Size));
  823.     end;
  824.     Inc(Y, H div 2);
  825.     SetTextJustify(CenterText, TopText);
  826.     SetUserCharSize(5, 6, 3, 2);
  827.     SetTextStyle(TriplexFont, HorizDir, UserCharSize);
  828.     OutTextXY((x2-x1) div 2, Y, 'User defined size!');
  829.   end;
  830.   WaitToGo;
  831. end; { TextPlay }
  832.  
  833. procedure TextDump;
  834. { Dump the complete character sets to the screen }
  835. const
  836.   CGASizes  : array[0..4] of word = (1, 3, 7, 3, 3);
  837.   NormSizes : array[0..4] of word = (1, 4, 7, 4, 4);
  838. var
  839.   Font : word;
  840.   ViewInfo : ViewPortType;
  841.   Ch : char;
  842. begin
  843.   for Font := 0 to 4 do
  844.   begin
  845.     MainWindow(Fonts[Font]+' character set');
  846.     GetViewSettings(ViewInfo);
  847.     with ViewInfo do
  848.     begin
  849.       SetTextJustify(LeftText, TopText);
  850.       MoveTo(2, 3);
  851.       if Font = DefaultFont then
  852.         begin
  853.           SetTextStyle(Font, HorizDir, 1);
  854.           Ch := #0;
  855.           repeat
  856.             OutText(Ch);
  857.             if (GetX + TextWidth('M')) > (x2-x1) then
  858.               MoveTo(2, GetY + TextHeight('M')+3);
  859.             Ch := Succ(Ch);
  860.           until (Ch >= #255);
  861.         end
  862.       else
  863.         begin
  864.           if MaxY < 200 then
  865.             SetTextStyle(Font, HorizDir, CGASizes[Font])
  866.           else
  867.             SetTextStyle(Font, HorizDir, NormSizes[Font]);
  868.           Ch := '!';
  869.           repeat
  870.             OutText(Ch);
  871.             if (GetX + TextWidth('M')) > (x2-x1) then
  872.               MoveTo(2, GetY + TextHeight('M')+3);
  873.             Ch := Succ(Ch);
  874.           until (Ord(Ch) = Ord('~')+1);
  875.         end;
  876.     end; { with }
  877.     WaitToGo;
  878.   end; { for loop }
  879. end; { TextDump }
  880.  
  881. procedure LineToPlay;
  882. { Demonstrate MoveTo and LineTo commands }
  883. const
  884.   MaxPoints = 15;
  885. var
  886.   Points     : array[0..MaxPoints] of PointType;
  887.   ViewInfo   : ViewPortType;
  888.   I, J       : integer;
  889.   CenterX    : integer;   { The center point of the circle }
  890.   CenterY    : integer;
  891.   Radius     : word;
  892.   StepAngle  : word;
  893.   Xasp, Yasp : word;
  894.   Radians    : real;
  895.  
  896. function AdjAsp(Value : integer) : integer;
  897. { Adjust a value for the aspect ratio of the device }
  898. begin
  899.   AdjAsp := (LongInt(Value) * Xasp) div Yasp;
  900. end; { AdjAsp }
  901.  
  902. begin
  903.   MainWindow('MoveTo, LineTo demonstration');
  904.   GetAspectRatio(Xasp, Yasp);
  905.   GetViewSettings(ViewInfo);
  906.   with ViewInfo do
  907.   begin
  908.     CenterX := (x2-x1) div 2;
  909.     CenterY := (y2-y1) div 2;
  910.     Radius := CenterY;
  911.     while (CenterY+AdjAsp(Radius)) < (y2-y1)-20 do
  912.       Inc(Radius);
  913.   end;
  914.   StepAngle := 360 div MaxPoints;
  915.   for I := 0 to MaxPoints - 1 do
  916.   begin
  917.     Radians := (StepAngle * I) * Pi / 180;
  918.     Points[I].X := CenterX + round(Cos(Radians) * Radius);
  919.     Points[I].Y := CenterY - AdjAsp(round(Sin(Radians) * Radius));
  920.   end;
  921.   Circle(CenterX, CenterY, Radius);
  922.   for I := 0 to MaxPoints - 1 do
  923.   begin
  924.     for J := I to MaxPoints - 1 do
  925.     begin
  926.       MoveTo(Points[I].X, Points[I].Y);
  927.       LineTo(Points[J].X, Points[J].Y);
  928.     end;
  929.   end;
  930.   WaitToGo;
  931. end; { LineToPlay }
  932.  
  933. procedure LineRelPlay;
  934. { Demonstrate MoveRel and LineRel commands }
  935. const
  936.   MaxPoints = 12;
  937. var
  938.   Poly     : array[1..MaxPoints] of PointType; { Stores a polygon for filling }
  939.   CurrPort : ViewPortType;
  940.  
  941. procedure DrawTesseract;
  942. { Draw a Tesseract on the screen with relative move and
  943.   line drawing commands, also create a polygon for filling }
  944. const
  945.   CheckerBoard : FillPatternType = (0, $10, $28, $44, $28, $10, 0, 0);
  946. var
  947.   X, Y, W, H   : integer;
  948.  
  949. begin
  950.   GetViewSettings(CurrPort);
  951.   with CurrPort do
  952.   begin
  953.     W := (x2-x1) div 9;
  954.     H := (y2-y1) div 8;
  955.     X := ((x2-x1) div 2) - round(2.5 * W);
  956.     Y := ((y2-y1) div 2) - (3 * H);
  957.  
  958.     { Border around viewport is outer part of polygon }
  959.     Poly[1].X := 0;     Poly[1].Y := 0;
  960.     Poly[2].X := x2-x1; Poly[2].Y := 0;
  961.     Poly[3].X := x2-x1; Poly[3].Y := y2-y1;
  962.     Poly[4].X := 0;     Poly[4].Y := y2-y1;
  963.     Poly[5].X := 0;     Poly[5].Y := 0;
  964.     MoveTo(X, Y);
  965.  
  966.     { Grab the whole in the polygon as we draw }
  967.     MoveRel(0, H);      Poly[6].X := GetX;  Poly[6].Y := GetY;
  968.     MoveRel(W, -H);     Poly[7].X := GetX;  Poly[7].Y := GetY;
  969.     MoveRel(4*W, 0);    Poly[8].X := GetX;  Poly[8].Y := GetY;
  970.     MoveRel(0, 5*H);    Poly[9].X := GetX;  Poly[9].Y := GetY;
  971.     MoveRel(-W, H);     Poly[10].X := GetX; Poly[10].Y := GetY;
  972.     MoveRel(-4*W, 0);   Poly[11].X := GetX; Poly[11].Y := GetY;
  973.     MoveRel(0, -5*H);   Poly[12].X := GetX; Poly[12].Y := GetY;
  974.  
  975.     { Fill the polygon with a user defined fill pattern }
  976.     SetFillPattern(CheckerBoard, RealFillColor(GreenPixel));
  977.     FillPoly(12, Poly);
  978.  
  979.     MoveRel(W, -H);
  980.     LineRel(0, 5*H);   LineRel(2*W, 0);    LineRel(0, -3*H);
  981.     LineRel(W, -H);    LineRel(0, 5*H);    MoveRel(0, -5*H);
  982.     LineRel(-2*W, 0);  LineRel(0, 3*H);    LineRel(-W, H);
  983.     MoveRel(W, -H);    LineRel(W, 0);      MoveRel(0, -2*H);
  984.     LineRel(-W, 0);
  985.  
  986.     { Flood fill the center }
  987.     FloodFill((x2-x1) div 2, (y2-y1) div 2,RealColor(WhitePixel));
  988.   end;
  989. end; { DrawTesseract }
  990.  
  991. begin
  992.   MainWindow('LineRel / MoveRel demonstration');
  993.   GetViewSettings(CurrPort);
  994.   with CurrPort do
  995.     { Move the viewport out 1 pixel from each end }
  996.     SetViewPort(x1-1, y1-1, x2+1, y2+1, ClipOn);
  997.   DrawTesseract;
  998.   WaitToGo;
  999. end; { LineRelPlay }
  1000.  
  1001. procedure PiePlay;
  1002. { Demonstrate  PieSlice and GetAspectRatio commands }
  1003. var
  1004.   ViewInfo   : ViewPortType;
  1005.   CenterX    : integer;
  1006.   CenterY    : integer;
  1007.   Radius     : word;
  1008.   Xasp, Yasp : word;
  1009.   X, Y       : integer;
  1010.  
  1011. function AdjAsp(Value : integer) : integer;
  1012. { Adjust a value for the aspect ratio of the device }
  1013. begin
  1014.   AdjAsp := (LongInt(Value) * Xasp) div Yasp;
  1015. end; { AdjAsp }
  1016.  
  1017. procedure GetTextCoords(AngleInDegrees, Radius : word; var X, Y : integer);
  1018. { Get the coordinates of text for pie slice labels }
  1019. var
  1020.   Radians : real;
  1021. begin
  1022.   Radians := AngleInDegrees * Pi / 180;
  1023.   X := round(Cos(Radians) * Radius);
  1024.   Y := round(Sin(Radians) * Radius);
  1025. end; { GetTextCoords }
  1026.  
  1027. begin
  1028.   MainWindow('PieSlice / GetAspectRatio demonstration');
  1029.   GetAspectRatio(Xasp, Yasp);
  1030.   GetViewSettings(ViewInfo);
  1031.   with ViewInfo do
  1032.   begin
  1033.     CenterX := (x2-x1) div 2;
  1034.     CenterY := ((y2-y1) div 2) + 20;
  1035.     Radius := (y2-y1) div 3;
  1036.     while AdjAsp(Radius) < round((y2-y1) / 3.6) do
  1037.       Inc(Radius);
  1038.   end;
  1039.   SetTextStyle(TriplexFont, HorizDir, 4);
  1040.   SetTextJustify(CenterText, TopText);
  1041.   OutTextXY(CenterX, 0, 'This is a pie chart!');
  1042.  
  1043.   SetTextStyle(TriplexFont, HorizDir, 3);
  1044.  
  1045.   SetFillStyle(SolidFill, RealFillColor(RandColor));
  1046.   PieSlice(CenterX+10, CenterY-AdjAsp(10), 0, 90, Radius);
  1047.   GetTextCoords(45, Radius, X, Y);
  1048.   SetTextJustify(LeftText, BottomText);
  1049.   OutTextXY(CenterX+10+X+TextWidth('H'), CenterY-AdjAsp(10+Y), '25 %');
  1050.  
  1051.   SetFillStyle(HatchFill, RealFillColor(RandColor));
  1052.   PieSlice(CenterX, CenterY, 225, 360, Radius);
  1053.   GetTextCoords(293, Radius, X, Y);
  1054.   SetTextJustify(LeftText, TopText);
  1055.   OutTextXY(CenterX+X+TextWidth('H'), CenterY-AdjAsp(Y), '37.5 %');
  1056.  
  1057.   SetFillStyle(InterleaveFill, RealFillColor(RandColor));
  1058.   PieSlice(CenterX-10, CenterY, 135, 225, Radius);
  1059.   GetTextCoords(180, Radius, X, Y);
  1060.   SetTextJustify(RightText, CenterText);
  1061.   OutTextXY(CenterX-10+X-TextWidth('H'), CenterY-AdjAsp(Y), '25 %');
  1062.  
  1063.   SetFillStyle(WideDotFill, RealFillColor(RandColor));
  1064.   PieSlice(CenterX, CenterY, 90, 135, Radius);
  1065.   GetTextCoords(112, Radius, X, Y);
  1066.   SetTextJustify(RightText, BottomText);
  1067.   OutTextXY(CenterX+X-TextWidth('H'), CenterY-AdjAsp(Y), '12.5 %');
  1068.  
  1069.   WaitToGo;
  1070. end; { PiePlay }
  1071.  
  1072. procedure Bar3DPlay;
  1073. { Demonstrate Bar3D command }
  1074. const
  1075.   NumBars   = 7;  { The number of bars drawn }
  1076.   BarHeight : array[1..NumBars] of byte = (1, 3, 2, 5, 4, 2, 1);
  1077.   YTicks    = 5;  { The number of tick marks on the Y axis }
  1078. var
  1079.   ViewInfo : ViewPortType;
  1080.   H        : word;
  1081.   XStep    : real;
  1082.   YStep    : real;
  1083.   I, J     : integer;
  1084.   Depth    : word;
  1085.   Color    : LongInt;
  1086. begin
  1087.   MainWindow('Bar3D / Rectangle demonstration');
  1088.   H := 3*TextHeight('M');
  1089.   GetViewSettings(ViewInfo);
  1090.   SetTextJustify(CenterText, TopText);
  1091.   SetTextStyle(TriplexFont, HorizDir, 4);
  1092.   OutTextXY(MaxX div 2, 6, 'These are 3D bars !');
  1093.   SetTextStyle(DefaultFont, HorizDir, 1);
  1094.   with ViewInfo do
  1095.     SetViewPort(x1+50, y1+40, x2-50, y2-10, ClipOn);
  1096.   GetViewSettings(ViewInfo);
  1097.   with ViewInfo do
  1098.   begin
  1099.     Line(H, H, H, (y2-y1)-H);
  1100.     Line(H, (y2-y1)-H, (x2-x1)-H, (y2-y1)-H);
  1101.     YStep := ((y2-y1)-(2*H)) / YTicks;
  1102.     XStep := ((x2-x1)-(2*H)) / NumBars;
  1103.     J := (y2-y1)-H;
  1104.     SetTextJustify(CenterText, CenterText);
  1105.  
  1106.     { Draw the Y axis and ticks marks }
  1107.     for I := 0 to Yticks do
  1108.     begin
  1109.       Line(H div 2, J, H, J);
  1110.       OutTextXY(0, J, Int2Str(I));
  1111.       J := Round(J-Ystep);
  1112.     end;
  1113.  
  1114.  
  1115.     Depth := trunc(0.25 * XStep);    { Calculate depth of bar }
  1116.  
  1117.     { Draw X axis, bars, and tick marks }
  1118.     SetTextJustify(CenterText, TopText);
  1119.     J := H;
  1120.     for I := 1 to Succ(NumBars) do
  1121.     begin
  1122.       SetColor(RealDrawColor(WhitePixel));
  1123.       Line(J, (y2-y1)-H, J, (y2-y1-3)-(H div 2));
  1124.       OutTextXY(J, (y2-y1)-(H div 2), Int2Str(I-1));
  1125.       if I <> Succ(NumBars) then
  1126.       begin
  1127.         Color := RandColor;
  1128.         SetFillStyle(I, RealFillColor(Color));
  1129.         SetColor(RealDrawColor(Color));
  1130.         Bar3D(J, round((y2-y1-H)-(BarHeight[I] * Ystep)),
  1131.                  round(J+Xstep-Depth), round((y2-y1)-H-1), Depth, TopOn);
  1132.         J := Round(J+Xstep);
  1133.       end;
  1134.     end;
  1135.  
  1136.   end;
  1137.   WaitToGo;
  1138. end; { Bar3DPlay }
  1139.  
  1140. procedure SolidBarPlay;
  1141. { Draw random solid bars on the screen }
  1142. var
  1143.   MaxWidth  : integer;
  1144.   MaxHeight : integer;
  1145.   ViewInfo  : ViewPortType;
  1146.   Color     : LongInt;
  1147. begin
  1148.   MainWindow('Random Solid Bars');
  1149.   StatusLine('Esc aborts or press a key');
  1150.   GetViewSettings(ViewInfo);
  1151.   with ViewInfo do
  1152.   begin
  1153.     MaxWidth := x2-x1;
  1154.     MaxHeight := y2-y1;
  1155.   end;
  1156.   repeat
  1157.     Color := RandColor;
  1158.     SetColor(RealDrawColor(Color));
  1159.     SetFillStyle(SolidFill, RealFillColor(Color));
  1160.     Bar3D(Random(MaxWidth), Random(MaxHeight),
  1161.           Random(MaxWidth), Random(MaxHeight), 0, TopOff);
  1162.   until KeyPressed;
  1163.   WaitToGo;
  1164. end; { SolidBarPlay }
  1165.  
  1166. procedure BarPlay;
  1167. { Demonstrate Bar command }
  1168. const
  1169.   NumBars   = 5;
  1170.   BarHeight : array[1..NumBars] of byte = (1, 3, 5, 2, 4);
  1171.   Styles    : array[1..NumBars] of byte = (1, 3, 10, 5, 9);
  1172. var
  1173.   ViewInfo  : ViewPortType;
  1174.   BarNum    : word;
  1175.   H         : word;
  1176.   XStep     : real;
  1177.   YStep     : real;
  1178.   I, J      : integer;
  1179.   Color     : LongInt;
  1180. begin
  1181.   MainWindow('Bar / Rectangle demonstration');
  1182.   H := 3*TextHeight('M');
  1183.   GetViewSettings(ViewInfo);
  1184.   SetTextJustify(CenterText, TopText);
  1185.   SetTextStyle(TriplexFont, HorizDir, 4);
  1186.   OutTextXY(MaxX div 2, 6, 'These are 2D bars !');
  1187.   SetTextStyle(DefaultFont, HorizDir, 1);
  1188.   with ViewInfo do
  1189.     SetViewPort(x1+50, y1+30, x2-50, y2-10, ClipOn);
  1190.   GetViewSettings(ViewInfo);
  1191.   with ViewInfo do
  1192.   begin
  1193.     Line(H, H, H, (y2-y1)-H);
  1194.     Line(H, (y2-y1)-H, (x2-x1)-H, (y2-y1)-H);
  1195.     YStep := ((y2-y1)-(2*H)) / NumBars;
  1196.     XStep := ((x2-x1)-(2*H)) / NumBars;
  1197.     J := (y2-y1)-H;
  1198.     SetTextJustify(CenterText, CenterText);
  1199.  
  1200.     { Draw Y axis with tick marks }
  1201.     for I := 0 to NumBars do
  1202.     begin
  1203.       Line(H div 2, J, H, J);
  1204.       OutTextXY(0, J, Int2Str(i));
  1205.       J := Round(J-Ystep);
  1206.     end;
  1207.  
  1208.     { Draw X axis, bars, and tick marks }
  1209.     J := H;
  1210.     SetTextJustify(CenterText, TopText);
  1211.     for I := 1 to Succ(NumBars) do
  1212.     begin
  1213.       SetColor(RealDrawColor(WhitePixel));
  1214.       Line(J, (y2-y1)-H, J, (y2-y1-3)-(H div 2));
  1215.       OutTextXY(J, (y2-y1)-(H div 2), Int2Str(I));
  1216.       if I <> Succ(NumBars) then
  1217.       begin
  1218.         Color := RandColor;
  1219.         SetFillStyle(Styles[I], RealFillColor(Color));
  1220.         SetColor(RealDrawColor(Color));
  1221.         Bar(J, round((y2-y1-H)-(BarHeight[I] * Ystep)), round(J+Xstep), (y2-y1)-H-1);
  1222.         Rectangle(J, round((y2-y1-H)-(BarHeight[I] * Ystep)), round(J+Xstep), (y2-y1)-H-1);
  1223.       end;
  1224.       J := Round(J+Xstep);
  1225.     end;
  1226.  
  1227.   end;
  1228.   WaitToGo;
  1229. end; { BarPlay }
  1230.  
  1231. procedure CirclePlay;
  1232. { Draw random circles on the screen }
  1233. var
  1234.   MaxRadius : word;
  1235. begin
  1236.   MainWindow('Circle demonstration');
  1237.   StatusLine('Esc aborts or press a key');
  1238.   MaxRadius := MaxY div 10;
  1239.   SetLineStyle(SolidLn, 0, NormWidth);
  1240.   repeat
  1241.     SetColor(RealDrawColor(RandColor));
  1242.     Circle(Random(MaxX), Random(MaxY), Random(MaxRadius));
  1243.   until KeyPressed;
  1244.   WaitToGo;
  1245. end; { CirclePlay }
  1246.  
  1247.  
  1248. procedure RandBarPlay;
  1249. { Draw random bars on the screen }
  1250. var
  1251.   MaxWidth  : integer;
  1252.   MaxHeight : integer;
  1253.   ViewInfo  : ViewPortType;
  1254.   Color     : LongInt;
  1255. begin
  1256.   MainWindow('Random Bars');
  1257.   StatusLine('Esc aborts or press a key');
  1258.   GetViewSettings(ViewInfo);
  1259.   with ViewInfo do
  1260.   begin
  1261.     MaxWidth := x2-x1;
  1262.     MaxHeight := y2-y1;
  1263.   end;
  1264.   repeat
  1265.     Color := RandColor;
  1266.     SetColor(RealDrawColor(Color));
  1267.     SetFillStyle(Random(CloseDotFill)+1, RealFillColor(Color));
  1268.     Bar3D(Random(MaxWidth), Random(MaxHeight),
  1269.           Random(MaxWidth), Random(MaxHeight), 0, TopOff);
  1270.   until KeyPressed;
  1271.   WaitToGo;
  1272. end; { RandBarPlay }
  1273.  
  1274. procedure ArcPlay;
  1275. { Draw random arcs on the screen }
  1276. var
  1277.   MaxRadius : word;
  1278.   EndAngle : word;
  1279.   ArcInfo : ArcCoordsType;
  1280. begin
  1281.   MainWindow('Arc / GetArcCoords demonstration');
  1282.   StatusLine('Esc aborts or press a key');
  1283.   MaxRadius := MaxY div 10;
  1284.   repeat
  1285.     SetColor(RealDrawColor(RandColor));
  1286.     EndAngle := Random(360);
  1287.     SetLineStyle(SolidLn, 0, NormWidth);
  1288.     Arc(Random(MaxX), Random(MaxY), Random(EndAngle), EndAngle, Random(MaxRadius));
  1289.     GetArcCoords(ArcInfo);
  1290.     with ArcInfo do
  1291.     begin
  1292.       Line(X, Y, XStart, YStart);
  1293.       Line(X, Y, Xend, Yend);
  1294.     end;
  1295.   until KeyPressed;
  1296.   WaitToGo;
  1297. end; { ArcPlay }
  1298.  
  1299. procedure PutPixelPlay;
  1300. { Demonstrate the PutPixel and GetPixel commands }
  1301. const
  1302.   Seed   = 1962; { A seed for the random number generator }
  1303.   NumPts = 2000; { The number of pixels plotted }
  1304.   Esc    = #27;
  1305. var
  1306.   I : word;
  1307.   X, Y : word;
  1308.   Color : LongInt;
  1309.   XMax, YMax  : integer;
  1310.   ViewInfo    : ViewPortType;
  1311. begin
  1312.   MainWindow('PutPixel / GetPixel demonstration');
  1313.   StatusLine('Esc aborts or press a key...');
  1314.  
  1315.   GetViewSettings(ViewInfo);
  1316.   with ViewInfo do
  1317.   begin
  1318.     XMax := (x2-x1-1);
  1319.     YMax := (y2-y1-1);
  1320.   end;
  1321.  
  1322.   while not KeyPressed do
  1323.   begin
  1324.     { Plot random pixels }
  1325.     RandSeed := Seed;
  1326.     I := 0;
  1327.     while (not KeyPressed) and (I < NumPts) do
  1328.     begin
  1329.       Inc(I);
  1330.       PutPixel(Random(XMax)+1, Random(YMax)+1, RealColor(RandColor));
  1331.     end;
  1332.  
  1333.     { Erase pixels }
  1334.     RandSeed := Seed;
  1335.     I := 0;
  1336.     while (not KeyPressed) and (I < NumPts) do
  1337.     begin
  1338.       Inc(I);
  1339.       X := Random(XMax)+1;
  1340.       Y := Random(YMax)+1;
  1341.       Color := RealPixelColor(GetPixel(X,Y));
  1342.       inline($89/$56/<Color);  (* Used to load 15-bit color value *)
  1343.       if Color = RandColor then
  1344.         PutPixel(X, Y, RealColor(0))
  1345.     end;
  1346.   end;
  1347.   WaitToGo;
  1348. end; { PutPixelPlay }
  1349.  
  1350. procedure PutImagePlay;
  1351. { Demonstrate the GetImage and PutImage commands }
  1352.  
  1353. const
  1354.   r  = 20;
  1355.   StartX = 100;
  1356.   StartY = 150;
  1357.  
  1358. var
  1359.   CurPort : ViewPortType;
  1360.  
  1361. procedure MoveSaucer(var X, Y : integer; Width, Height : integer);
  1362. var
  1363.   Step : integer;
  1364. begin
  1365.   Step := Random(2*r);
  1366.   if Odd(Step) then
  1367.     Step := -Step;
  1368.   X := X + Step;
  1369.   Step := Random(r);
  1370.   if Odd(Step) then
  1371.     Step := -Step;
  1372.   Y := Y + Step;
  1373.  
  1374.   { Make saucer bounce off viewport walls }
  1375.   with CurPort do
  1376.   begin
  1377.     if (x1 + X + Width - 1 > x2) then
  1378.       X := x2-x1 - Width + 1
  1379.     else
  1380.       if (X < 0) then
  1381.         X := 0;
  1382.     if (y1 + Y + Height - 1 > y2) then
  1383.       Y := y2-y1 - Height + 1
  1384.     else
  1385.       if (Y < 0) then
  1386.         Y := 0;
  1387.   end;
  1388. end; { MoveSaucer }
  1389.  
  1390. var
  1391.   Pausetime : word;
  1392.   Saucer    : pointer;
  1393.   X, Y      : integer;
  1394.   ulx, uly  : word;
  1395.   lrx, lry  : word;
  1396.   Size      : longint;
  1397.   I         : word;
  1398. begin
  1399.   ClearDevice;
  1400.   FullPort;
  1401.  
  1402.   { PaintScreen }
  1403.   ClearDevice;
  1404.   MainWindow('GetImage / PutImage Demonstration');
  1405.   StatusLine('Esc aborts or press a key...');
  1406.   GetViewSettings(CurPort);
  1407.  
  1408.   { DrawSaucer }
  1409.   Ellipse(StartX, StartY, 0, 360, r, (r div 3)+2);
  1410.   Ellipse(StartX, StartY-4, 190, 357, r, r div 3);
  1411.   Line(StartX+7, StartY-6, StartX+10, StartY-12);
  1412.   Circle(StartX+10, StartY-12, 2);
  1413.   Line(StartX-7, StartY-6, StartX-10, StartY-12);
  1414.   Circle(StartX-10, StartY-12, 2);
  1415.   SetFillStyle(SolidFill, RealFillColor(BluePixel));
  1416.   FloodFill(StartX+1, StartY+4, RealColor(WhitePixel));
  1417.  
  1418.   { ReadSaucerImage }
  1419.   ulx := StartX-(r+1);
  1420.   uly := StartY-14;
  1421.   lrx := StartX+(r+1);
  1422.   lry := StartY+(r div 3)+3;
  1423.  
  1424.   case GetMaxColor of
  1425.     16:  Size := ImageSize(ulx, uly, lrx, lry);
  1426.     256: Size := (lrx-uly)*(lry-uly)+4;
  1427.     65535,32768: Size := 2*(lrx-uly)*(lry-uly)+4;
  1428.     16777: Size := 4*(lrx-uly)*(lry-uly)+4;
  1429.   end;
  1430.   GetMem(Saucer, Size);
  1431.   GetImage(ulx, uly, lrx, lry, Saucer^);
  1432.   PutImage(ulx, uly, Saucer^, XORput);               { erase image }
  1433.   { Plot some "stars" }
  1434.   for I := 1 to 1000 do
  1435.     PutPixel(Random(MaxX), Random(MaxY), RealColor(RandColor));
  1436.   X := MaxX div 2;
  1437.   Y := MaxY div 2;
  1438.   PauseTime := 70;
  1439.  
  1440.   { Move the saucer around }
  1441.   repeat
  1442.     X := (X div 8)*8;
  1443.     PutImage(X, Y, Saucer^, XORput);                 { draw image }
  1444.     Delay(PauseTime);
  1445.     PutImage(X, Y, Saucer^, XORput);                 { erase image }
  1446.     MoveSaucer(X, Y, lrx - ulx + 1, lry - uly + 1);  { width/height }
  1447.   until KeyPressed;
  1448.   FreeMem(Saucer, size);
  1449.   WaitToGo;
  1450. end; { PutImagePlay }
  1451.  
  1452. procedure PolyPlay;
  1453. { Draw random polygons with random fill styles on the screen }
  1454. const
  1455.   MaxPts = 5;
  1456. type
  1457.   PolygonType = array[1..MaxPts] of PointType;
  1458. var
  1459.   Poly : PolygonType;
  1460.   I : word;
  1461.   Color : LongInt;
  1462. begin
  1463.   MainWindow('FillPoly demonstration');
  1464.   StatusLine('Esc aborts or press a key...');
  1465.   repeat
  1466.     Color := RandColor;
  1467.     SetFillStyle(Random(11)+1, RealFillColor(Color));
  1468.     SetColor(RealDrawColor(Color));
  1469.     for I := 1 to MaxPts do
  1470.       with Poly[I] do
  1471.       begin
  1472.         X := Random(MaxX);
  1473.         Y := Random(MaxY);
  1474.       end;
  1475.     FillPoly(MaxPts, Poly);
  1476.   until KeyPressed;
  1477.   WaitToGo;
  1478. end; { PolyPlay }
  1479.  
  1480. procedure FillStylePlay;
  1481. { Display all of the predefined fill styles available }
  1482. var
  1483.   Style    : word;
  1484.   Width    : word;
  1485.   Height   : word;
  1486.   X, Y     : word;
  1487.   I, J     : word;
  1488.   ViewInfo : ViewPortType;
  1489.  
  1490. procedure DrawBox(X, Y : word);
  1491. begin
  1492.   SetFillStyle(Style, RealFillColor(WhitePixel));
  1493.   with ViewInfo do
  1494.     Bar(X, Y, X+Width, Y+Height);
  1495.   Rectangle(X, Y, X+Width, Y+Height);
  1496.   OutTextXY(X+(Width div 2), Y+Height+4, Int2Str(Style));
  1497.   Inc(Style);
  1498. end; { DrawBox }
  1499.  
  1500. begin
  1501.   MainWindow('Pre-defined fill styles');
  1502.   GetViewSettings(ViewInfo);
  1503.   with ViewInfo do
  1504.   begin
  1505.     Width := 2 * ((x2+1) div 13);
  1506.     Height := 2 * ((y2-10) div 10);
  1507.   end;
  1508.   X := Width div 2;
  1509.   Y := Height div 2;
  1510.   Style := 0;
  1511.   for J := 1 to 3 do
  1512.   begin
  1513.     for I := 1 to 4 do
  1514.     begin
  1515.       DrawBox(X, Y);
  1516.       Inc(X, (Width div 2) * 3);
  1517.     end;
  1518.     X := Width div 2;
  1519.     Inc(Y, (Height div 2) * 3);
  1520.   end;
  1521.   SetTextJustify(LeftText, TopText);
  1522.   WaitToGo;
  1523. end; { FillStylePlay }
  1524.  
  1525. procedure FillPatternPlay;
  1526. { Display some user defined fill patterns }
  1527. const
  1528.   Patterns : array[0..11] of FillPatternType = (
  1529.   ($AA, $55, $AA, $55, $AA, $55, $AA, $55),
  1530.   ($33, $33, $CC, $CC, $33, $33, $CC, $CC),
  1531.   ($F0, $F0, $F0, $F0, $F, $F, $F, $F),
  1532.   (0, $10, $28, $44, $28, $10, 0, 0),
  1533.   (0, $70, $20, $27, $25, $27, $4, $4),
  1534.   (0, 0, 0, $18, $18, 0, 0, 0),
  1535.   (0, 0, $3C, $3C, $3C, $3C, 0, 0),
  1536.   (0, $7E, $7E, $7E, $7E, $7E, $7E, 0),
  1537.   (0, 0, $22, $8, 0, $22, $1C, 0),
  1538.   ($FF, $7E, $3C, $18, $18, $3C, $7E, $FF),
  1539.   (0, $10, $10, $7C, $10, $10, 0, 0),
  1540.   (0, $42, $24, $18, $18, $24, $42, 0));
  1541. var
  1542.   Style    : word;
  1543.   Width    : word;
  1544.   Height   : word;
  1545.   X, Y     : word;
  1546.   I, J     : word;
  1547.   ViewInfo : ViewPortType;
  1548.  
  1549. procedure DrawBox(X, Y : word);
  1550. begin
  1551.   SetFillPattern(Patterns[Style], RealFillColor(WhitePixel));
  1552.   with ViewInfo do
  1553.     Bar(X, Y, X+Width, Y+Height);
  1554.   Rectangle(X, Y, X+Width, Y+Height);
  1555.   Inc(Style);
  1556. end; { DrawBox }
  1557.  
  1558. begin
  1559.   MainWindow('User defined fill styles');
  1560.   GetViewSettings(ViewInfo);
  1561.   with ViewInfo do
  1562.   begin
  1563.     Width := 2 * ((x2+1) div 13);
  1564.     Height := 2 * ((y2-10) div 10);
  1565.   end;
  1566.   X := Width div 2;
  1567.   Y := Height div 2;
  1568.   Style := 0;
  1569.   for J := 1 to 3 do
  1570.   begin
  1571.     for I := 1 to 4 do
  1572.     begin
  1573.       DrawBox(X, Y);
  1574.       Inc(X, (Width div 2) * 3);
  1575.     end;
  1576.     X := Width div 2;
  1577.     Inc(Y, (Height div 2) * 3);
  1578.   end;
  1579.   SetTextJustify(LeftText, TopText);
  1580.   WaitToGo;
  1581. end; { FillPatternPlay }
  1582.  
  1583. procedure ColorPlay;
  1584. { Display all of the colors available for the current driver and mode }
  1585. var
  1586.   Color      : LongInt;
  1587.   Width, Wid : word;
  1588.   Height, Ht : word;
  1589.   Ofs        : word;
  1590.   Sx, Sy, Mx, My, X, Y : Word;
  1591.   I, J       : word;
  1592.   ViewInfo   : ViewPortType;
  1593.  
  1594. procedure DrawBox(X, Y : word; drawzr : boolean);
  1595. begin
  1596.   SetFillStyle(SolidFill, RealFillColor(Color));
  1597.   SetColor(RealDrawColor(Color));
  1598.   with ViewInfo do
  1599.     Bar(X, Y, X+Width, Y+Height);
  1600.   Rectangle(X, Y, X+Width, Y+Height);
  1601.   if Color = 0 then
  1602.   begin
  1603.     if drawzr then
  1604.     begin
  1605.       SetColor(RealDrawColor(WhitePixel));
  1606.       Rectangle(X, Y, X+Width, Y+Height);
  1607.     end;
  1608.   end;
  1609.   Color := Succ(Color);
  1610. end; { DrawBox }
  1611.  
  1612. function cRGB(R : longint; G : longint; B : longint) : LongInt;
  1613. begin
  1614.   if (GetMaxColor = 32767) then
  1615.     cRGB := (((R SHR 1) AND 31) shl 10)+(((G SHR 1) and 31) shl 5)+
  1616.             ((B SHR 1) and 31)
  1617.   else if (GetMaxColor = 65535) then
  1618.     cRGB := (((R SHR 1) AND 31) shl 11) OR (((G SHR 1) and 63) shl 5) OR
  1619.             ((B SHR 1) and 31)
  1620.   else
  1621.     cRGB := (R shl 18)+(G shl 10)+(B SHL 2);
  1622. end;
  1623.  
  1624. begin
  1625.   begin
  1626.     GetViewSettings(ViewInfo);
  1627.     Wid := ViewInfo.x2-ViewInfo.x1;
  1628.     Ht  := ViewInfo.y2-ViewInfo.y1;
  1629.     Mx := Wid div 2;
  1630.     My := Ht div 2;
  1631.  
  1632.     if (GetMaxColor = 255) then
  1633.     begin
  1634.       Width  := (Wid div 16)-1;
  1635.       Height := (Ht  div 16)-1;
  1636.       MainWindow('256 Color demonstration');
  1637.  
  1638.       X := (Mx - (Width+1)*8);
  1639.       Y := (My - (Height+1)*8);
  1640.       for I := 0 to 15 do
  1641.       begin
  1642.     for J := 0 to 15 do
  1643.     begin
  1644.       Color := (I shl 4) + J;
  1645.           DrawBox(X,Y,true);
  1646.           Inc(X,Width+1);
  1647.         end;
  1648.         X := (Mx - (Width+1)*8);
  1649.         Inc(Y,Height+1);
  1650.       end;
  1651.     end
  1652.     else if (GetMaxColor = 15) then
  1653.     begin
  1654.       Height := (Ht div 16)-1;
  1655.       MainWindow('16 Color demonstration');
  1656.  
  1657.       X := 0;
  1658.       Y := 0;
  1659.       for I := 0 to 15 do
  1660.        begin
  1661.         Color := I;
  1662.         DrawBox(X,Y,true);
  1663.         Inc(Y,Height+1);
  1664.       end;
  1665.     end
  1666.     else
  1667.     begin
  1668.       if (GetMaxColor = 32767) then
  1669.         MainWindow('32768 Color demonstration')
  1670.       else if (GetMaxColor = 65535) then
  1671.         MainWindow('65536 Color demonstration')
  1672.       else if (GetMaxColor = 16777) then
  1673.         MainWindow('24 bit Color demonstration')
  1674.       else
  1675.         MainWindow('Color demonstration');
  1676.  
  1677.       Width  := (Wid shr 7)-1;
  1678.       Height := (Ht  shr 7)-1;
  1679.       Y := ((My - ((Height+1) shl 6)) shr 1);
  1680.       for I := 0 to 63 do
  1681.       begin
  1682.         X := (Mx - ((Width+1) shl 6)) shr 1;
  1683.         for J := 0 to 63 do
  1684.         begin
  1685.           color := cRGB(i,j,0);
  1686.           DrawBox(x,y,false);
  1687.           color := cRGB(i,0,j);
  1688.           DrawBox(x+Mx,y,false);
  1689.           color := cRGB(0,i,j);
  1690.           DrawBox(x,y+My,false);
  1691.           color := cRGB(i,j,(i+j) shr 1);
  1692.           DrawBox(x+Mx,y+My,false);
  1693.           Inc(X,Width+1);
  1694.         end;
  1695.         Inc(Y,Height+1);
  1696.       end;
  1697. {
  1698.       Height := (Height+1) shl 2;
  1699.       Width  := (Wid shr 8)-1;
  1700.       X := Mx - (Width shl 8);
  1701.       Y := Ht - (Height shl 2);
  1702.  
  1703.       for I := 0 to 255 do
  1704.       begin
  1705.         color := cRGB(i,0,0);
  1706.         DrawBox(x,y,false);
  1707.         color := cRGB(0,i,0);
  1708.         DrawBox(x,y+Height+1,false);
  1709.         color := cRGB(0,0,i);
  1710.         DrawBox(x,y+(Height+1) shl 1,false);
  1711.         Inc(X,Width+1);
  1712.       end; }
  1713.     end;
  1714.   end;
  1715.   WaitToGo;
  1716. end; { ColorPlay }
  1717.  
  1718. procedure PalettePlay;
  1719. { Demonstrate the use of the SetRGBPalette command }
  1720. const
  1721.   XBars = 15;
  1722.   YBars = 10;
  1723. type
  1724.   RGBColor   = record
  1725.                  R, G, B : byte;
  1726.                end;
  1727.   VGAPalette = array[0..255] of RGBColor;
  1728.  
  1729. var
  1730.   I, J     : word;
  1731.   X, Y     : word;
  1732.   Color    : word;
  1733.   ViewInfo : ViewPortType;
  1734.   Width    : word;
  1735.   Height   : word;
  1736.   VGAPal   : VGAPalette;
  1737.   Rand     : integer;
  1738.  
  1739. procedure ReadDACBlock(Start, Count : integer; var Pal : VGAPalette);
  1740. var
  1741.   Regs : Registers;
  1742. begin
  1743.   with Regs do
  1744.   begin
  1745.     AH := $10;
  1746.     AL := $17;
  1747.     BX := Start;
  1748.     CX := Count;
  1749.     ES := Seg(Pal);
  1750.     DX := Ofs(Pal);
  1751.   end;
  1752.   Intr($10, Regs);
  1753. end;
  1754.  
  1755. procedure SetDACBlock(Start, Count : integer; var Pal : VGAPalette);
  1756. var
  1757.   Regs : Registers;
  1758. begin
  1759.   with Regs do
  1760.   begin
  1761.     AH := $10;
  1762.     AL := $12;
  1763.     BX := Start;
  1764.     CX := Count;
  1765.     ES := Seg(Pal);
  1766.     DX := Ofs(Pal);
  1767.   end;
  1768.   Intr($10, Regs);
  1769. end;
  1770.  
  1771. begin
  1772.   if (GetMaxColor <= 256) then
  1773.   begin
  1774.     ReadDACBlock(0, 256, VGAPal);
  1775.     MainWindow('SetRGBPalette demonstration');
  1776.     StatusLine('Press any key...');
  1777.     GetViewSettings(ViewInfo);
  1778.     with ViewInfo do
  1779.     begin
  1780.       Width := (x2-x1) div XBars;
  1781.       Height := (y2-y1) div YBars;
  1782.     end;
  1783.     X := 0; Y := 0;
  1784.     Color := 0;
  1785.     for J := 1 to YBars do
  1786.     begin
  1787.       for I := 1 to XBars do
  1788.       begin
  1789.         SetFillStyle(SolidFill, RealFillColor(Color));
  1790.         Bar(X, Y, X+Width, Y+Height);
  1791.         Inc(X, Width+1);
  1792.         Inc(Color);
  1793.         Color := Color mod 16;
  1794.       end;
  1795.       X := 0;
  1796.       Inc(Y, Height+1);
  1797.     end;
  1798.     repeat
  1799.       {SetPalette(Random(16), VGAPal[Random(256)]);}
  1800.       with VGAPal[Random(16)] do
  1801.         SetRGBPalette(Random(16), R, G, B);
  1802.     until KeyPressed;
  1803.     SetDACBlock(0, 256, VGAPal);
  1804.     WaitToGo;
  1805.   end;
  1806. end; { PalettePlay }
  1807.  
  1808. procedure PagingPlay;
  1809. { Demonstrate setactivepage/setvisualpage }
  1810. var
  1811.   ViewInfo : ViewPortType;
  1812.   Ch       : Char;
  1813. begin
  1814.   SetActivePage(1);
  1815.   MainWindow('SetActivePage/SetVisualPage demo');
  1816.   StatusLine('Press any key for page 0...');
  1817.   SetVisualPage(1);
  1818.   SetActivePage(0);
  1819.   MainWindow('SetActivePage/SetVisualPage demo');
  1820.   GetViewSettings(ViewInfo);
  1821.  
  1822.   SetFillStyle(SolidFill, RealFillColor(GreenPixel));
  1823.   with ViewInfo do
  1824.   begin
  1825.     SetTextJustify(LeftText,CenterText);
  1826.     OutTextXY(10, (y2-y1) div 2, 'This is page 0');
  1827.     SetFillStyle(SolidFill, RealFillColor(GreenPixel));
  1828.     Bar(0,0,x2-x1,((y2-y1) div 2) - 10);
  1829.     OutTextXY(10,10, 'There should only be one green bar');
  1830.     OutTextXY(10,20, 'if paging is supported in this mode');
  1831.  
  1832.     SetActivePage(1);
  1833.     SetTextJustify(RightText, CenterText);
  1834.     OutTextXY((x2-x1)-10, (y2-y1) div 2, 'This is page 1');
  1835.         SetFillStyle(SolidFill, RealFillColor(GreenPixel));
  1836.     Bar(0,((y2-y1) div 2) + 10,x2-x1,y2-y1);
  1837.     SetActivePage(0);
  1838.  
  1839.     repeat until KeyPressed;
  1840.     Ch := ReadKey;
  1841.     SetVisualPage(0);
  1842.   end;
  1843.   WaitToGo;
  1844. end;
  1845.  
  1846. procedure CrtModePlay;
  1847. { Demonstrate the use of RestoreCrtMode and SetGraphMode }
  1848. var
  1849.   ViewInfo : ViewPortType;
  1850.   Ch       : char;
  1851. begin
  1852.   MainWindow('SetGraphMode / RestoreCrtMode demo');
  1853.   GetViewSettings(ViewInfo);
  1854.   SetTextJustify(CenterText, CenterText);
  1855.   with ViewInfo do
  1856.   begin
  1857.     OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'Now you are in graphics mode');
  1858.     StatusLine('Press any key for text mode...');
  1859.     repeat until KeyPressed;
  1860.     Ch := ReadKey;
  1861.     RestoreCrtmode;
  1862.     Writeln('Now you are in text mode.');
  1863.     Write('Press any key to go back to graphics...');
  1864.     repeat until KeyPressed;
  1865.     Ch := ReadKey;
  1866.     SetGraphMode(GetGraphMode);
  1867.     MainWindow('SetGraphMode / RestoreCrtMode demo');
  1868.     SetTextJustify(CenterText, CenterText);
  1869.     OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'Back in graphics mode...');
  1870.   end;
  1871.   WaitToGo;
  1872. end; { CrtModePlay }
  1873.  
  1874. procedure LineStylePlay;
  1875. { Demonstrate the predefined line styles available }
  1876. var
  1877.   Style    : word;
  1878.   Step     : word;
  1879.   X, Y     : word;
  1880.   ViewInfo : ViewPortType;
  1881.  
  1882. begin
  1883.   ClearDevice;
  1884.   DefaultColors;
  1885.   MainWindow('Pre-defined line styles');
  1886.   GetViewSettings(ViewInfo);
  1887.   with ViewInfo do
  1888.   begin
  1889.     X := 35;
  1890.     Y := 10;
  1891.     Step := (x2-x1) div 11;
  1892.     SetTextJustify(LeftText, TopText);
  1893.     OutTextXY(X, Y, 'NormWidth');
  1894.     SetTextJustify(CenterText, TopText);
  1895.     for Style := 0 to 3 do
  1896.     begin
  1897.       SetLineStyle(Style, 0, NormWidth);
  1898.       Line(X, Y+20, X, Y2-40);
  1899.       OutTextXY(X, Y2-30, Int2Str(Style));
  1900.       Inc(X, Step);
  1901.     end;
  1902.     Inc(X, 2*Step);
  1903.     SetTextJustify(LeftText, TopText);
  1904.     OutTextXY(X, Y, 'ThickWidth');
  1905.     SetTextJustify(CenterText, TopText);
  1906.     for Style := 0 to 3 do
  1907.     begin
  1908.       SetLineStyle(Style, 0, ThickWidth);
  1909.       Line(X, Y+20, X, Y2-40);
  1910.       OutTextXY(X, Y2-30, Int2Str(Style));
  1911.       Inc(X, Step);
  1912.     end;
  1913.   end;
  1914.   SetTextJustify(LeftText, TopText);
  1915.   WaitToGo;
  1916. end; { LineStylePlay }
  1917.  
  1918. procedure UserLineStylePlay;
  1919. { Demonstrate user defined line styles }
  1920. var
  1921.   Style    : word;
  1922.   X, Y, I  : word;
  1923.   ViewInfo : ViewPortType;
  1924. begin
  1925.   MainWindow('User defined line styles');
  1926.   GetViewSettings(ViewInfo);
  1927.   with ViewInfo do
  1928.   begin
  1929.     X := 4;
  1930.     Y := 10;
  1931.     Style := 0;
  1932.     I := 0;
  1933.     while X < X2-4 do
  1934.     begin
  1935.       {$B+}
  1936.       Style := Style or (1 shl (I mod 16));
  1937.       {$B-}
  1938.       SetLineStyle(UserBitLn, Style, NormWidth);
  1939.       Line(X, Y, X, (y2-y1)-Y);
  1940.       Inc(X, 5);
  1941.       Inc(I);
  1942.       if Style = 65535 then
  1943.       begin
  1944.         I := 0;
  1945.         Style := 0;
  1946.       end;
  1947.     end;
  1948.   end;
  1949.   WaitToGo;
  1950. end; { UserLineStylePlay }
  1951.  
  1952.  
  1953. procedure SayGoodbye;
  1954. { Say goodbye and then exit the program }
  1955. var
  1956.   ViewInfo : ViewPortType;
  1957. begin
  1958.   MainWindow('');
  1959.   GetViewSettings(ViewInfo);
  1960.   SetTextStyle(TriplexFont, HorizDir, 4);
  1961.   SetTextJustify(CenterText, CenterText);
  1962.   with ViewInfo do
  1963.     OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'That''s all folks!');
  1964.   StatusLine('Press any key to quit...');
  1965.   repeat until KeyPressed;
  1966. end; { SayGoodbye }
  1967.  
  1968. begin { program body }
  1969.   ClrScr;
  1970.   writeln('VGA BGI Demo Program  Copyright(c) 1987,1989 Borland International, Inc.');
  1971.   writeln;
  1972.   Initialize;
  1973.   ReportStatus;
  1974. {  PagingPlay; }
  1975.   AspectRatioPlay;
  1976.   FillEllipsePlay;
  1977.   SectorPlay;
  1978.   WriteModePlay;
  1979.   ColorPlay;
  1980.   PalettePlay;
  1981.   PutPixelPlay;
  1982.   PutImagePlay;
  1983.   RandBarPlay;
  1984.   SolidBarPlay;
  1985.   BarPlay;
  1986.   Bar3DPlay;
  1987.   ArcPlay;
  1988.   CirclePlay;
  1989.   PiePlay;
  1990.   LineToPlay;
  1991.   LineRelPlay;
  1992.   LineStylePlay;
  1993.   UserLineStylePlay;
  1994.   TextDump;
  1995.   TextPlay;
  1996.   CrtModePlay;
  1997.   FillStylePlay;
  1998.   FillPatternPlay;
  1999.   PolyPlay;
  2000.   SayGoodbye;
  2001.   CloseGraph;
  2002. end.
  2003.